perm filename PMATCH.SAI[AL,HE]3 blob
sn#358173 filedate 1978-05-30 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00025 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002
C00010 00003 ! debugging cruft
C00015 00004 ! lstcmp
C00017 00005 ! strcmp
C00018 00006 ! eltcmp
C00021 00007 ! lopptr & lstrdr
C00022 00008 ! dobind
C00025 00009 ! pattcmp
C00027 00010 ! ubs
C00028 00011 ! insert_rec & pickslot
C00032 00012 ! wldinx, tstwix, etc
C00037 00013 ! cpywld,difwld,andwld,orwld
C00039 00014 ! say_relies
C00042 00015 ! ffbsimp,tfbsimp,dfcheck,dffrget
C00045 00016 ! alert,usefct,relieve,guarded
C00047 00017 ! gen_facts,true_in
C00049 00018 ! $pdsc$
C00051 00019 ! pattdsc
C00052 00020 ! pattblk
C00054 00021 ! bapply,execpatt,do_demons,set_demon
C00057 00022 ! asrtf, denyf, asrtpf & denypf
C00060 00023 ! pmatch itself
C00068 00024 ! lpmatch, lpasrt, lpdeny
C00069 00025 ! test program
C00074 ENDMK
C⊗;
DEFINE PMDEBUGGING = 0;
IFCR ¬DECLARATION(PMBUGGY) THENC
DEFINE PMBUGGY = PMDEBUGGING;
ENDC
IFCR ¬PMDEBUGGING THENC
ENTRY;
ELSEC
DEFINE BAILING = "TRUE";
ENDC
BEGIN "PMATCH"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING ="FALSE";ENDC
IFCR ¬ CREFFING THENC
REQUIRE "ABBREV.SAI[AL,HE]" SOURCE_FILE;
REQUIRE "MACROS.SAI[AL,HE]" SOURCE_FILE;
REQUIRE "STCODE.DEF[AL,HE]" SOURCE_FILE;
REQUIRE "REFBTS.DEF[AL,HE]" SOURCE_FILE;
REQUIRE "RECAUX.HDR[AL,HE]" SOURCE_FILE;
REQUIRE "LEPAUX.HDR[AL,HE]" SOURCE_FILE;
REQUIRE "PMATCH.HDR[AL,HE]" SOURCE_FILE;
ENDC
REQUIRE "SYS:PROCES.DEF" SOURCE_FILE;
REQUIRE "PRINTX.HDR[AL,HE]" SOURCE_FILE;
REQUIRE "ARYAUX.HDR[AL,HE]" SOURCE_FILE;
DEFINE H1(X) "⊂⊃" = ⊂((X) LSH -18)⊃,
H2(X) "⊂⊃" = ⊂((X) LAND '777777)⊃;
DEFINE DBMAX=500;
INTEGER DBTOP,
NWLDS;
BOOLEAN SIMPLE PROCEDURE CRCALL;
START_CODE
EXTERNAL INTEGER SPROUT;
MOVE 1,('12);
HLRZ 1,1(1);
HRRZ 1,(1);
CAIE 1,SPROUT;
TDZA 1,1;
MOVEI 1,1;
END;
INTERNAL RECORD_CLASS FACT(RECORD_POINTER(ANY_CLASS) PATT;
RECORD_POINTER(ANY_CLASS) ITEMVAR ID;
INTEGER USECNT,WM1,WM2,WM3,WM4,WM5,WM6);
DEFINE UCIX=3; ! *** MUST be the index of the usecnt field;
DEFINE WMIX=4; ! *** MUST be the index of the first WM field;
DEFINE UNTRUE(F) "[]" =
[ (FACT:WM1[F]=FACT:WM2[F]=FACT:WM3[F]=FACT:WM4[F]=FACT:WM5[F]=FACT:WM6[F]=0) ];
! the ID field is assumed to contain a pointer to the FACT record.
One thing to be aware of is that this will cause the fact record to be
immortal (at least until the item is deleted). Since (1) in the current
application facts are almost never denied everywhere, and (2) the
present implementation did not zap "empty" facts anyhow, there
is no great loss in all this.
;
INTERNAL RPTR(FACT) _FACT_; ! used to hold the last fact returned by
PMATCH. Also, when DEMONs are called,
holds the name of the fact being asserted
or denied (that caused the demon to
to be invoked). The demon procedure
is assumed to munch _FACT_,_WLD_, and
_DEMONF_, and the demon invoker will
put these variables back to their
"previous" condition;
INTERNAL ITEMVAR _WLD_; ! holds world last used in asrtf or denyf;
INTERNAL RPTR(FACT) _DEMONF_; ! holds factid of current when_asserting or
when_denying procedure;
INTERNAL ITEMVAR _OCCASION_; ! holds occasion for invocation of current demon;
OWN RECORD_POINTER(FACT) ARRAY DBASE[1:DBMAX];
OWN ITEMVAR ARRAY WORLDS[0:WLDMAX];
OWN INTERNAL ITEMVAR ARRAY GUARD[0:WLDMAX];
OWN INTERNAL ITEMVAR ARRAY CLEAR[0:WLDMAX];
INTERNAL DXITEM(ACTIVE_ALERT);
INTERNAL DXITEM(ALERT_ORDER);
INTERNAL DXITEM(WHEN_ASSERT);
INTERNAL DXITEM(WHEN_DENY);
INTERNAL ITEMVAR NEEDS_TO_LIVE,SELF_RELY;
INTERNAL RCLASS FBOOL(INTEGER ANDORNOT;RPTR(CELL) ARGS);
! 1 for "and", 2 for "or", 3 for "not";
! This fellow is intended for forming boolean
combinations of facts. Currently, used by
the relies_on business;
RPTR(FACT) ITEMVAR FF1;RPTR(FBOOL,FACT) FF2;
RPTR(ANY_CLASS) RLYPTN,RLYRTR,SLFPTN;
FORWARD RECURSIVE PROCEDURE DFCHECK(RPTR(FACT) ITEMVAR F;RPTR(FBOOL,FACT) FB);
FORWARD RECURSIVE PROCEDURE DFFRGT;
PROCEDURE RLYINI;
BEGIN
NEEDS_TO_LIVE ← XITEM("NEEDS_TO_LIVE");
SELF_RELY ← XITEM("SELF_RELY");
RLYPTN←PATTBLK(\(NEEDS_TO_LIVE,FF1,FF2));
RLYRTR←PATTBLK(\(NEEDS_TO_LIVE,? FF1, BIND FF2));
SLFPTN←PATTBLK(\(SELF_RELY));
ASSIGN(NEEDS_TO_LIVE,DFCHECK);
ASSIGN(SELF_RELY,DFFRGT);
END;
REQUIRE RLYINI INITIALIZATION;
INTEGER SIMPLE PROCEDURE SIGNUM(INTEGER I);
START_CODE
LABEL XIT;
SKIPN 1,I;
JRST XIT;
CAIG 1,0;
SKIPA 1,[-1];
MOVEI 1,1;
XIT: END;
SIMPLE BOOLEAN PROCEDURE EMPTY(INTEGER I);
RETURN(DBASE[I]=NULL_RECORD ∨ FACT:USECNT[DBASE[I]]≤0);
SIMPLE INTEGER PROCEDURE JFFO_IX(INTEGER M);
START_CODE
LABEL L;
SKIPE 1,M;
JFFO 1,L;
SOSA 1;
L: MOVE 1,2;
END;
RPTR($CLASS) ARRAY PTYPES[0:12];
SIMPLE PROCEDURE INIDB;
BEGIN DBTOP←0;NWLDS←-1;
ARRCLR(PTYPES);
END;
REQUIRE INIDB INITIALIZATION [0];
! debugging cruft;
INTERNAL INTEGER PMDBTF,PMCAL;
INITIALIZE(PMCAL←0);
BITDEF(TELTC,1);
BITDEF(TPATTC,2);
BITDEF(TINSRT,4);
BITDEF(TASRT,'10);
BITDEF(TDENY,'20);
BITDEF(TPMATCH,'40);
BITDEF(TUSFCT,'100); DEFINE TRACE_USEFCT = [ PMDBTF LAND TUSFCT ];
BITDEF(TDEMONS,'200);
BITDEF(TDOBIND,'400);
INTERNAL SIMPLE PROCEDURE PMDBST;
BEGIN
OUTSTR("
Set pmatch debugging options:
Trace eltcmp 1
Trace pattcmp 2
Trace insert_rec 4
Trace asrtpf '10
Trace denypf '20
Trace pmatch '40
Trace usefct '100
Trace demons '200
Trace dobind '400
Type in one fhq octal number:");
PMDBTF←CVO(INCHWL);
END;
PROCEDURE FPRT(RPTR(FACT) F);
PRINT("< FACT ",FACT:ID[F]," >");
RECPROC FBPRT(RPTR(FBOOL) FB);
BEGIN
PRINT("(","∧∨¬"[FBOOL:ANDORNOT[FB] FOR 1]);
RECPRN(FBOOL:ARGS[FB]);
PRINT(")")
END;
INITIALIZE(SETRPM(LOCATION(FACT),LOCATION(FPRT)));
INITIALIZE(SETRPM(LOCATION(FBOOL),LOCATION(FBPRT)));
INTERNAL PROCEDURE FACT_PRINT(RPTR (FACT) F;INTEGER WIX(-1));
BEGIN
ITEMVAR W,OCSN;RPTR(FACT) ITEMVAR DMN;
INTEGER N,I,PTN;
PRINT("( ",FACT:ID[F],": ");
PTN←MEM[LOC(FACT:PATT[F])];
N←RECLEN(FACT:PATT[F]);
FOR I←1 STEP 1 UNTIL N DO
BEGIN
PRINTX(MEM[PTN+I]);
PRINT(" ");
END;
PRINT(") ",FACT:USECNT[F]," ");
IF WIX < 0 THEN
∀ W | TRUE_IN(F,W) DO
BEGIN "WPLP"
PRINT(" ",W);
END
ELSE
BEGIN
FOR W←WORLDS[WIX],GUARD[WIX] DO
IF TRUE_IN(F,W) THEN
PRINT(" ",W);
∀ W | ACTIVE_ALERT⊗WORLDS[WIX]≡W DO
IF TRUE_IN(F,W) THEN
PRINT(" ",W);
END;
FOR OCSN←WHEN_ASSERT,WHEN_DENY DO
IF OCSN⊗FACT:ID[F]≡ANY THEN
BEGIN
PRINT("{",OCSN,":");
∀ DMN | OCSN⊗FACT:ID[F]≡DMN DO
PRINT(DMN," ");
PRINT("} ");
END;
END;
INTERNAL PROCEDURE WIXPRT(INTEGER I);
BEGIN
ITEMVAR WW;
PRINT(I,":"&TAB,WORLDS[I]);
IF CLEAR[I]≠ANY THEN
PRINT(TAB&"CLEAR=",CLEAR[I]);
IF GUARD[I]≠ANY THEN
PRINT(TAB&"GUARD=",GUARD[I]);
IF ACTIVE_ALERT⊗WORLDS[I]≡ANY THEN
BEGIN
PRINT(TAB&"ALERTS:");
∀ WW | ACTIVE_ALERT⊗WORLDS[I]≡WW DO
PRINT(" ",WW);
END;
PRINT(CRLF);
END;
INTERNAL PROCEDURE WIXDMP;
BEGIN
INTEGER I;
PRINT(CRLF&"WORLD ID NUMBERS"&CRLF);
FOR I←0 STEP 1 UNTIL NWLDS DO
WIXPRT(I);
END;
INTERNAL PROCEDURE DBDUMP(INTEGER MN(1),MX(DBMAX));
BEGIN
INTEGER I;
MX←DBTOP MIN MX;
PRINT(CRLF&"DUMP OF DATA BASE FROM ",MN," TO ",MX);
FOR I←MN STEP 1 UNTIL MX DO
BEGIN
PRINT(CRLF,I,":"&TAB);
FACT_PRINT(DBASE[I]);
PRINT(CRLF);
END;
WIXDMP;
END;
SIMPLE INTEGER PROCEDURE I$P(INTEGER I);
BEGIN
PRINT(I);
RETURN(I);
END;
INTERNAL PROCEDURE WLDDMP(ITEMVAR WLD);
BEGIN
IF WLD=ANY THEN
DBDUMP
ELSE
BEGIN
RPTR(FACT) F;
INTEGER WIX;
WIX←WLDINX(WLD);
PRINT(CRLF&"FACTS TRUE IN ",WLD,
" AND RELATED WORLDS ");
∀ | GEN_FACTS(F,WLD) DO
BEGIN
PRINT(CRLF);
FACT_PRINT(F,WIX);
END;
PRINT(CRLF&"WORLD INFO IS:");
WIXPRT(WIX);
END;
END;
! lstcmp;
INTERNAL INTEGER SIMPROC LSTCMP(REFERENCE LIST L1,L2;INTEGER LGO('777777));
START_CODE
LABEL L1DON,L2DON,XIT,NXT,XIT1;
SETZ 1,; ! -1 < , 0=, 1> ;
MOVE 2,LGO; ! LGO IS MAX LEN INTO LIST TO GO;
MOVE 3,L1; ! PICK UP LIST 1 PTR;
MOVE 4,L2; ! DITTO LIST 2;
JUMPE 3,L1DON;
JUMPE 4,L2DON;
NXT: SOJL 2,XIT; ! IF EQUAL TO HERE, THEN QUIT;
HRRZ 3,(3); ! NEXT OF L1;
HRRZ 4,(4); ! NEXT OF L2;
JUMPE 3,L1DON;
JUMPE 4,L2DON;
HLRZ 5,(3);
HLRZ 6,(4);
JUMPE 5,NXT; ! TREAT ANY AS A DON'T CARE;
JUMPE 6,NXT; ! TREAT ANY AS A DON'T CARE;
CAMN 5,6;
JRST NXT;
CAML 5,6;
AOJA 1,XIT; ! L1>L2;
SOJA 1,XIT; ! L1<L2;
L1DON: JUMPE 4,XIT;
SOJA 1,XIT; ! IF L2 NOT DONE, L1<L2;
L2DON: CAIE 3,0; ! IF L1 NOT DONE, L1>L2;
MOVEI 1,1;
XIT: END; ! SAIL WILL UNDO ARGS;
! strcmp;
INTERNAL INTEGER SIMPLE PROCEDURE STRCMP(STRING S1,S2);
BEGIN
INTEGER I,C1,C2,L;
L←LENGTH(C1) MIN LENGTH(C2);
FOR I←1 STEP 1 UNTIL L DO
BEGIN
C1←LOP(S1);C2←LOP(S2);
IF C1>C2 THEN RETURN(1);
IF C1<C2 THEN RETURN(-1);
END;
RETURN(SIGNUM(LENGTH(S1)-LENGTH(S2)));
END;
! eltcmp;
INTERNAL INTEGER RECURSIVE PROCEDURE ELTCMP(INTEGER D1,D2);
BEGIN
INTEGER T1,T2,Q1,Q2,L1,L2,RV;
LABEL RVL;
DEFINE IARCODE="18";
DEFINE ICODE="5";
SIMPLE PROCEDURE SIMPCMP;
RV←SIGNUM(Q1-Q2);
SIMPLE PROCEDURE UNDEFERR;
BEGIN
USERERR(1,1,"UNDEFINED FIELD TO ELTCMP");
RV←0;
END;
T1←(D1 LSH -23) LAND '777;
T2←(D2 LSH -23) LAND '777;
IF (RV←SIGNUM(T1-T2)) THEN GO TO RVL;
! TYPES ARE THE SAME;
! here, RV=0;
IF BINDB_ON(D1) ∨ BINDB_ON(D2) THEN GO TO RVL;
T2←T2 LAND '77;
IF (T1 LAND '100) THEN T2←INTEGER_CODE+ARYBRK
ELSE IF T1 LAND '600 THEN T2←INTEGER_CODE;
IF T2>MXSTYP THEN
BEGIN
T2←(T2-ARYBRK) LSH 23;
Q1←H2(MEMORY[D1]) + T2;
Q2←H2(MEMORY[D2]) + T2;
IF Q1=T2 THEN
L1← Q1
ELSE
L1←H2(MEMORY[MEMORY[Q1]-1]) + Q1;
IF Q2=T2 THEN
L2← Q2
ELSE
L2←H2(MEMORY[MEMORY[Q2]-1]) + Q2;
WHILE L1>Q1 ∧ L2>Q2 DO
BEGIN
RV←ELTCMP(Q1,Q2);
IF RV THEN GO TO RVL;
IF T2=(16 LSH 23) THEN
BEGIN
Q1←Q1+2;
Q2←Q2+2;
END
ELSE
BEGIN
Q1←Q1+1;
Q2←Q2+1;
END;
END;
RV←SIGNUM(L1-L2);
GO TO RVL;
END;
Q1←MEMORY[D1];
Q2←MEMORY[D2];
CASE T2 OF
BEGIN
[0] UNDEFERR;
[1] SIMPCMP;
[2] SIMPCMP;
[3] START_CODE "STRINGCOMP"
MOVE 1,Q1;
PUSH '16,-1(1);
PUSH '16,(1);
MOVE 1,Q2;
PUSH '16,-1(1);
PUSH '16,(1);
PUSHJ '17,STRCMP;
MOVEM 1,RV;
END;
[4] SIMPCMP;
[5] SIMPCMP;
[6] RV←LSTCMP(MEMORY[D1,LIST],MEMORY[D2,LIST]);
[7] RV←LSTCMP(MEMORY[D1,LIST],MEMORY[D2,LIST]);
[8] SIMPCMP;
[9] SIMPCMP;
[10] SIMPCMP;
[11] SIMPCMP;
[12] RV←ELTCMP(Q1,Q2);
[13] SIMPCMP
END;
RVL:
IF TELTC_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"ELTCMP:");
PRINTX(D1);PRINT(" VS ");PRINTX(D2);
PRINT(" →→ ",RV,CRLF);
END;
RETURN(RV);
END;
! lopptr & lstrdr;
ITEMVAR SIMPROC LOPPTR(REFERENCE INTEGER PTR);
START_CODE
LABEL XXX;
SKIPN 2,@-1('17);
JRST XXX;
MOVE 2,(2);
HLRZ 1,2;
HRRZM 2,@-1('17);
XXX: END;
INTEGER SIMPROC LSTRDR(REFERENCE LIST L);
START_CODE
SKIPE 1,@-1('17);
HRRZ 1,(1);
END;
! dobind;
PROCEDURE DOBIND(INTEGER D1,D2);
BEGIN
! binds D1 to the value of D2;
INTEGER QQ;
INTEGER T1,T2;
IF TDOBIND_ON(PMDBTF) THEN
BEGIN
PRINT("DOBIND("&CVOS(D1)&","&CVOS(D2)&"): ");
PRINTX(D1);PRINT(" VS ");PRINTX(D2);
PRINT(CRLF);
END;
T1←(D1 LSH -23) LAND '777;
T2←(D2 LSH -23) LAND '777;
IF T1≠T2 THEN
BEGIN
USERERR(1,1,"DRYROT: BINDING INCOMPATIBLE TYPES");
RETURN;
END;
IF ¬BINDB_ON(D1) THEN RETURN;
IF BINDB_ON(D2) THEN RETURN;
IF H2(D1)=H2(D2) THEN RETURN; ! same binding already;
T2←T2 LAND '77;
IF T1 LAND '600 ∧ ¬(T1 LAND '100) THEN
QQ←5
ELSE IF T1 LAND '100 THEN
QQ←17
ELSE
QQ←T2;
IF QQ > MXSTYP THEN
BEGIN
IF MEMORY[D1] THEN
ARYEL(MEMORY[D1]);
IF MEMORY[D2] THEN
BEGIN
MEMORY[D1]←ARCOP(MEMORY[D2]);
IF (T2=SET_CODE+ARYBRK) ∨ (T2=LIST_CODE+ARYBRK) THEN
BEGIN
QQ←H2(MEMORY[MEMORY[D2]-1]);
WHILE QQ>0 DO
BEGIN
MEMORY[D1+QQ]←0;
MEMORY[D1+QQ,LIST]←
MEMORY[D2+QQ,LIST];
QQ←QQ-1;
END;
END;
END
ELSE
MEMORY[D1]←0;
RETURN
END;
IF QQ=SET_CODE ∨ QQ=LIST_CODE THEN
BEGIN
MEMORY[D1,LIST]←MEMORY[D2,LIST];
END
ELSE IF QQ=STRING_CODE THEN
START_CODE
MOVE 1,D1;
HRRO 2,D2;
POP 2,(1);
POP 2,-1(1);
END
ELSE
MEMORY[D1]←MEMORY[D2];
END;
! pattcmp;
INTEGER PROCEDURE PATTCMP(REFERENCE RPTR(ANY_CLASS) P1,P2;
INTEGER HOWFAR('777777));
BEGIN
INTEGER P1I,P2I,L1,L2,L,RV;
LABEL RL;
P1I←MEM[LOC(P1)];
P2I←MEM[LOC(P2)];
L1←$CLASS:RECSIZ[$RECTYPE(P1)];
L2←$CLASS:RECSIZ[$RECTYPE(P2)];
L← (L1 MIN L2) MIN HOWFAR;
WHILE L>0 DO
BEGIN
P1I←P1I+1;
P2I←P2I+1;
RV←ELTCMP(MEM[P1I],MEM[P2I]);
IF RV THEN GO TO RL;
L←L-1;
END;
RV←IF (L1 MIN L2)=HOWFAR THEN 0 ELSE SIGNUM(L1-L2);
RL:
IF TPATTC_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"PATTCMP: ");
RECPRN(P1);PRINT(" VS ");RECPRN(P2);
PRINT(" FOR '"&CVOS(HOWFAR)&" →→ ",RV,CRLF);
END;
RETURN(RV);
END;
! ubs;
INTERNAL INTEGER SIMPROC UBS(INTEGER PROCEDURE PROBE; INTEGER L,U);
BEGIN
! RETURNS INDEX IF FIND RECORD, -M IF DONT;
! BASED ON KNUTH, V3 P407;
! NOTE *** This procedure must be simple to work
(context of PROBE problems) ***;
INTEGER I,CS;
WHILE L≤U DO
BEGIN
I←(L+U) ASH -1;
IF I=0 THEN CS←1
ELSE CS←PROBE(I);
IF CS<0 THEN
U←I-1
ELSE IF CS>0 THEN
L←I+1
ELSE
RETURN(I);
END;
RETURN(-L);
END;
! insert_rec & pickslot;
INTEGER SIMPROC PICKSLOT(INTEGER M);
BEGIN
INTEGER I,L;
IF M>DBTOP THEN
BEGIN
DBASE[DBTOP←M]←NEW_RECORD(FACT);
RETURN(M);
END;
IF EMPTY(M) THEN
RETURN(M);
L← (DBTOP-M) MIN (M-1);
FOR I←1 STEP 1 UNTIL L DO
BEGIN
IF EMPTY(M-I) THEN RETURN(M-I);
IF EMPTY(M+I) THEN RETURN(M+I);
END;
IF M-L=1 THEN
BEGIN
FOR I←(M+L+1) STEP 1 UNTIL DBTOP DO
BEGIN
IF EMPTY(I) THEN RETURN(I);
END;
END
ELSE IF DBTOP=DBMAX THEN
BEGIN
FOR I←(M-L)-1 STEP -1 UNTIL 1 DO
IF EMPTY(I) THEN RETURN(I);
END;
IF DBTOP<DBMAX THEN
BEGIN
DBTOP←DBTOP+1;
DBASE[DBTOP]←NEW_RECORD(FACT);
RETURN(DBTOP);
END;
USERERR(0,0,"URK! DBASE FULL");
END;
INTEGER PROCEDURE INSERT_REC(RPTR(ANY_CLASS) P;INTEGER IX(0));
BEGIN
INTEGER SLT,I;
RPTR(FACT) F;
INTEGER SIMPLE PROCEDURE PROBEI(REFERENCE INTEGER I);
RETURN(PATTCMP(P,FACT:PATT[DBASE[I]]));
IF IX=0 THEN IX←UBS(PROBEI,1,DBTOP);
IF TINSRT_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"INSERTING ");
RECPRN(P);
PRINT(" WITH IX=",IX,CRLF);
END;
IF IX>0 THEN RETURN(IX);
IX←-IX;
SLT←PICKSLOT(IX);
IF TINSRT_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"PICKED SLT= ",SLT," FOR IX=",IX,CRLF);
END;
IF SLT≠IX THEN
BEGIN
INTEGER SLTH;
SLTH←MEM[LOC(DBASE[SLT])];
IF SLT>IX THEN
START_CODE "SLTGTR"
PROTECT_ACS 2,3,4;
LABEL L1,L2;
MOVEI 2,ACCESS(DBASE[IX]);
MOVEI 3,ACCESS(DBASE[SLT]);
L1: CAIG 3,(2);
JRST L2;
MOVE 4,-1(3);
MOVEM 4,(3);
SOJA 3,L1;
L2: MOVE 4,SLTH;
MOVEM 4,(2);
END
ELSE
START_CODE "SLTLSS"
PROTECT_ACS 2,3,4;
LABEL L1;
MOVEI 2,ACCESS(DBASE[IX]);
MOVEI 3,ACCESS(DBASE[SLT]);
CAIL 3,-1(2);
JRST L1;
HRLI 3,1(3);
BLT 3,-2(2);
L1: MOVE 4,SLTH;
MOVEM 4,-1(2);
SOS IX; ! so point at slot;
END;
END;
F←DBASE[IX];
IF FACT:ID[F]=ANY THEN
FACT:ID[F]←NEW(F)
ELSE
BEGIN
! **** ugh, blech ****;
ERASE ANY⊗ANY≡FACT:ID[F];
ERASE FACT:ID[F]⊗ANY≡ANY;
ERASE ANY⊗FACT:ID[F]≡ANY;
END;
FACT:PATT[F]←P;
FACT:USECNT[F]←0;
FACT:WM1[F]←0;
FACT:WM2[F]←0;
FACT:WM3[F]←0;
RETURN(IX);
END;
! wldinx, tstwix, etc;
INTERNAL INTEGER SIMPLE PROCEDURE WLDINX(ITEMVAR W;INTEGER NEWFLG(0));
START_CODE
LABEL L0,L1,L2,L3,L4,L5,XIT;
EXTERNAL INTEGER DATM;
MOVNI 1,1;
SKIPG 3,W; ! Used to be SKIPG. RF;
JRST 4,XIT; ! *** is again. ANY is NOT a valid world, dammit ***;
MOVE 1,@DATM;
CAIL 1,0;
CAMLE 1,NWLDS;
JRST L0;
CAMN 3,WORLDS[0](1);
JRST XIT;
L0: SKIPGE 1,NWLDS;
JRST L2;
L1: CAME 3,WORLDS[0](1);
SOJGE 1,L1;
JUMPGE 1,XIT;
L2: SKIPN 1,NEWFLG;
SOJA 1,XIT; ! return -1 if not find;
SKIPGE 1,NWLDS;
JRST L4;
L3: SKIPN WORLDS[0](1);
JRST L5;
SOJGE 1,L3;
L4: AOS 1,NWLDS;
CAIG 1,WLDMAX;
JRST L5;
MOVEI 1,0;
PUSH '17,1; ! value;
PUSH '17,1; ! code;
MOVEI 2,48;
PUSH '16,2; ! 1st word of string pointer for message;
PUSH '16,["MAXIMUM NUMBER OF WORLDS EXCEEDED - CONTACT ARG!"];
PUSH '16,1; ! response = null;
PUSH '16,1;
PUSHJ '17,USERERR; ! call usererr routine;
L5: MOVEM 3,WORLDS[0](1);
SETZM GUARD[0](1);
SETZM CLEAR[0](1);
XIT: END;
INTERNAL BOOLEAN SIMPLE PROCEDURE TSTWIX(REFERENCE RPTR(FACT) F;INTEGER IX);
START_CODE
LABEL XIT0;
SKIPE 4,@F; ! record pointer;
SKIPGE 2,IX;
JRST XIT0;
IDIVI 2,36;
ADD 2,4;
MOVE 1,WMIX(2);
LSH 1,(3);
TLNN 1,'400000;
XIT0: TDZA 1,1;
MOVNI 1,1;
END;
INTERNAL SIMPLE PROCEDURE SETWLD(REFERENCE RPTR(FACT) F;INTEGER IX);
START_CODE
LABEL XIT;
SKIPE 4,@F;
SKIPGE 2,IX;
JRST 4,XIT;
IDIVI 2,36;
ADDI 2,WMIX(4);
HRLZI 5,'400000;
MOVN 3,3;
LSH 5,(3);
TDNN 5,(2);
AOS UCIX(4); ! bump usecnt;
IORM 5,(2);
XIT: END;
INTERNAL PROCEDURE CLRWLD(REFERENCE RPTR(FACT) F;INTEGER IX);
START_CODE
LABEL XIT;
SKIPE 4,@F;
SKIPGE 2,IX;
JRST 4,XIT;
IDIVI 2,36;
ADDI 2,WMIX(4);
HRLZI 5,'400000;
MOVN 3,3;
LSH 5,(3);
TDNE 5,(2);
SOS UCIX(4); ! bump usecnt;
ANDCAM 5,(2);
XIT: END;
INTERNAL SIMPLE PROCEDURE CLRALL(INTEGER WIX);
START_CODE
LABEL L1,L2,XIT;
SKIPGE 2,WIX;
JRST 4,XIT;
IDIVI 2,36;
ADD 2,['4000000+WMIX];
HRLZI 5,'400000;
MOVN 3,3;
LSH 5,(3);
MOVE 6,DBTOP;
SOJL 6,XIT;
L1: SKIPN 4,DBASE[1](6);
JRST L2;
TDNE 5,@2;
SOS UCIX(4); ! decrement usecnt;
ANDCAM 5,@2;
L2: SOJGE 6,L1;
XIT: END;
INTERNAL PROCEDURE ZAPWLD(ITEMVAR W);
BEGIN
INTEGER WX,I;
WX←WLDINX(W);
IF ¬WX THEN RETURN;
CLRALL(WX);
WORLDS[WX]←CVI(0);
IF WX=NWLDS THEN NWLDS←NWLDS-1;
END;
INTERNAL INTEGER ITEMVAR PROCEDURE NEWWLD;
BEGIN
INTEGER ITEMVAR NW;
NW←NEW(-1);
∂(NW)←WLDINX(NW,-1);
NEW_PNAME(NW,"W"&CVOS(#(NW)));
RETURN(NW);
END;
! cpywld,difwld,andwld,orwld;
INTERNAL PROCEDURE CPYWLD(ITEMVAR IW,OW);
BEGIN
INTEGER IWX,OWX,I;
RPTR(FACT) F;
IWX←WLDINX(IW);
OWX←WLDINX(OW);
FOR I←1 STEP 1 UNTIL DBTOP DO
BEGIN
F←DBASE[I];
IF TSTWIX(F,IWX) THEN
SETWLD(F,OWX)
ELSE
CLRWLD(F,OWX);
END;
END;
INTERNAL PROCEDURE DIFWLD(ITEMVAR W1,W2,WD);
BEGIN
INTEGER W1X,W2X,WDX,I;
RPTR(FACT) F;
W1X←WLDINX(W1);
W2X←WLDINX(W2);
WDX←WLDINX(WD);
FOR I←1 STEP 1 UNTIL DBTOP DO
BEGIN
F←DBASE[I];
IF TSTWIX(F,W1X)∧¬TSTWIX(F,W2X) THEN
SETWLD(F,WDX)
ELSE
CLRWLD(F,WDX);
END;
END;
INTERNAL PROCEDURE ANDWLD(ITEMVAR W1,W2,WD);
BEGIN
INTEGER W1X,W2X,WDX,I;
RPTR(FACT) F;
W1X←WLDINX(W1);
W2X←WLDINX(W2);
WDX←WLDINX(WD);
FOR I←1 STEP 1 UNTIL DBTOP DO
BEGIN
F←DBASE[I];
IF TSTWIX(F,W1X)∧TSTWIX(F,W2X) THEN
SETWLD(F,WDX)
ELSE
CLRWLD(F,WDX);
END;
END;
INTERNAL PROCEDURE ORWLD(ITEMVAR W1,W2,WD);
BEGIN
INTEGER W1X,W2X,WDX,I;
RPTR(FACT) F;
W1X←WLDINX(W1);
W2X←WLDINX(W2);
WDX←WLDINX(WD);
FOR I←1 STEP 1 UNTIL DBTOP DO
BEGIN
F←DBASE[I];
IF TSTWIX(F,W1X)∨TSTWIX(F,W2X) THEN
SETWLD(F,WDX)
ELSE
CLRWLD(F,WDX);
END;
END;
! say_relies;
RECURSIVE PROCEDURE FBMAP(ITEMVAR WLD;RPTR(FACT) ITEMVAR FP;RPTR(FACT,FBOOL) FB);
BEGIN
RPTR(CELL) AL;
IF RECTYPE(FB)=LOC(FACT) THEN
BEGIN
MAKE WHEN_DENY⊗FACT:ID[FB]≡FP;
END
ELSE
BEGIN
AL←FBOOL:ARGS[FB];
WHILE AL≠NULL_RECORD DO
BEGIN
FBMAP(WLD,FP,CELL:CAR[AL]);
AL←CELL:CDR[AL];
END;
END;
END;
INTERNAL RECURSIVE PROCEDURE SAY_RELIES(ITEMVAR WLD;
RPTR(FACT) ITEMVAR F1;
RPTR(FACT,FBOOL) FB);
BEGIN
! says that F1 relies on F2 in world W;
RPTR(FACT) F;
F←LPASRT(WLD,\( NEEDS_TO_LIVE, $ F1, $ FB));
FBMAP(WLD,FACT:ID[F],FB);
F←ASRTPF(WLD,SLFPTN);
MAKE WHEN_ASSERT⊗F1≡FACT:ID[F];
MAKE WHEN_DENY⊗F1≡FACT:ID[F];
END;
SET RECPROC RLYSET(RPTR(FACT,FBOOL) FB);
BEGIN
IF RECTYPE(FB)=LOC(FACT) THEN
RETURN({FACT:ID[FB]})
ELSE IF RECTYPE(FB)=LOC(FBOOL) THEN
BEGIN
RPTR(CELL) C; SET RS;
RS←PHI;
IF FBOOL:ANDORNOT[FB]≠1 THEN
USERERR(1,1,"RLYSET: FBOOL RELATION NOT ""AND""");
C←FBOOL:ARGS[FB];
WHILE C≠NULL_RECORD DO
RS←RS ∪ RLYSET(LLOP(C));
RETURN(RS);
END
ELSE
USERERR(1,1,"BAD ARG: RLYSET");
RETURN(PHI);
END;
INTERNAL SET PROCEDURE RELIANCE(ITEMVAR WLD;RPTR(FACT) ITEMVAR FI);
BEGIN
! returns the set of fact items upon which F relies in world WLD.
prints a warning if there are any "or" relations.
;
SET RS;
RS←PHI;
FF1←FI;
∀ | PMATCH(WLD,RLYRTR,TRUE) DO
RS←RS ∪ RLYSET(FF2);
RETURN(RS);
END;
! ffbsimp,tfbsimp,dfcheck,dffrget;
RPTR(FBOOL) PROCEDURE NEW_FBOOL(INTEGER AON;RPTR(CELL) AL);
BEGIN
RPTR(FBOOL) FB;
FB←NEW_RECORD(FBOOL);
FBOOL:ANDORNOT[FB]←AON;
FBOOL:ARGS[FB]←AL;
RETURN(FB);
END;
RPTR(FBOOL,FACT) RECPROC FFBSIMP(RPTR(FBOOL,FACT) FB,FFB);
BEGIN
RPTR(CELL) NAL,AL;
RANY X;
RPTR(FBOOL,FACT) N;
BOOLEAN FLAG;
IF RECTYPE(FB)=LOC(FACT) THEN
BEGIN
IF FB=FFB THEN
RETURN(NULL_RECORD)
ELSE
RETURN(FB);
END;
IF FBOOL:ANDORNOT[FB]=3 THEN
BEGIN
BUG("FFBSIMP DOESN'T HANDLE ""NOT"" YET");
END;
AL←FBOOL:ARGS[FB];
WHILE AL≠NULL_RECORD DO
BEGIN
N←CELL:CAR[AL];AL←CELL:CDR[AL];
X←FFBSIMP(N,FFB);
IF X=NULL_RECORD THEN
IF FBOOL:ANDORNOT[FB]=1 THEN RETURN(NULL_RECORD);
IF X≠N THEN FLAG←TRUE;
IF X≠NULL_RECORD THEN
NAL←CONS(X,NAL);
END;
IF NAL=NULL_RECORD THEN RETURN(NULL_RECORD);
IF FLAG THEN
BEGIN
IF CELL:CDR[NAL]=NULL_RECORD THEN
RETURN(CELL:CAR[NAL])
ELSE
RETURN(NEW_FBOOL(FBOOL:ANDORNOT[FB],NAL));
END;
RETURN(FB);
END;
RECURSIVE PROCEDURE DFCHECK(RPTR(FACT) ITEMVAR F;RPTR(FACT,FBOOL) FB);
BEGIN
ITEMVAR WLD;
RPTR(FBOOL,FACT) FFB;
FFB←FFBSIMP(FB,_FACT_);
WLD←_WLD_;
DENYF(WLD,_DEMONF_);
IF FFB=NULL_RECORD THEN
DENYF(_WLD_,∂(F))
ELSE
SAY_RELIES(_WLD_,F,FFB);
_WLD_←WLD;
END;
RECURSIVE PROCEDURE DFFRGT;
BEGIN
ITEMVAR WLD;
FF1←FACT:ID[_FACT_];
WLD←_WLD_;
∀ | PMATCH(WLD,RLYRTR,TRUE) DO
BEGIN
DENYF(WLD,_FACT_);
END;
END;
! alert,usefct,relieve,guarded;
INTERNAL ITEMVAR PROCEDURE PREP_ALERT(ITEMVAR W);
BEGIN
INTEGER ITEMVAR WW;
WW←NEWWLD;
CPYWLD(W,WW);
GUARD[∂(WW)]←NEWWLD;
MAKE ACTIVE_ALERT⊗W≡WW;
MAKE ALERT_ORDER⊗W≡WW;
RETURN(WW);
END;
INTERNAL PROCEDURE CALL_ALERT(ITEMVAR W);
BEGIN
ITEMVAR WW;
∀ WW | ALERT_ORDER⊗W≡WW DO
BEGIN
CPYWLD(W,WW);
CLRALL(WLDINX(GUARD[WLDINX(WW)]));
END;
END;
INTERNAL PROCEDURE USEFCT(RPTR(FACT) F;ITEMVAR WLD);
BEGIN
ITEMVAR WW;
∀ WW | ACTIVE_ALERT⊗WLD≡WW DO
BEGIN
INTEGER WWIX;
WWIX←WLDINX(WW);
IF TRACE_USEFCT THEN
BEGIN
PRINT(CRLF&
"TESTING FACT FOR MEMBERSHIP IN WORLD ",
WW,CRLF);
FACT_PRINT(F,WWIX);
END;
IF TSTWIX(F,WWIX) THEN
SETWLD(F,WLDINX(GUARD[WWIX]));
END;
END;
INTERNAL PROCEDURE RELIEVE(RPTR(FACT) F;ITEMVAR WLD);
BEGIN
INTEGER WIX,CWIX;
IF (WLD≠ANY)∧(WLD≠BINDIT) THEN
BEGIN
WIX←WLDINX(WLD);
IF WIX≥0 ∧ CLEAR[WIX]≠ANY THEN
BEGIN
CWIX←WLDINX(CLEAR[WIX]);
CLRWLD(F,CWIX);
END;
END;
END;
INTERNAL PROCEDURE COPY_ALERTS(ITEMVAR W1,W2);
BEGIN
ITEMVAR WW;
ERASE ACTIVE_ALERT⊗W2≡WW;
∀ WW | ACTIVE_ALERT⊗W1≡WW DO
MAKE ACTIVE_ALERT⊗W2≡WW;
END;
! gen_facts,true_in;
INTERNAL MATCHING RECPROC GEN_FACTS(REFERENCE RPTR(FACT) F;ITEMVAR W);
BEGIN
INTEGER I,WIX;
WIX←WLDINX(W);
FOR I ← 1 STEP 1 UNTIL DBTOP DO
BEGIN
F←DBASE[I];
IF TSTWIX(F,WIX) THEN SUCCEED;
END;
FAIL;
END;
INTERNAL MATCHING RECPROC TRUE_IN(RPTR (FACT) F;? ITEMVAR W);
BEGIN
INTEGER M,IX1,IX2,M1,M2,M3;
IF UNBOUND(W) THEN
BEGIN
IX1←0;
M1←FACT:WM1[F];M2←FACT:WM2[F];M3←FACT:WM3[F];
IF W=ANY THEN
BEGIN
IF M1∨M2∨M3 THEN
SUCCEED
END
ELSE FOR M←M1,M2,M3 DO
BEGIN "MLOOP"
WHILE (IX1←JFFO_IX(M))≥0 DO
BEGIN
W←WORLDS[IX1+IX2];
SUCCEED;
M ← M XOR (1 LSH (35-IX1));
END;
IX2←IX2+36;
END;
END
ELSE IF TSTWIX(F,WLDINX(W)) THEN
SUCCEED
ELSE FAIL;
END;
! $pdsc$;
RPTR(ANY_CLASS) PROCEDURE $PDSC$(INTEGER OP;RPTR(ANY_CLASS) A1);
BEGIN
IF OP=DELETE_RECORD THEN
BEGIN
INTEGER I,NN;
IF A1=NULL_RECORD THEN RETURN(NULL_RECORD);
NN←RECLEN(A1)+MEM[LOC(A1)];
FOR I←MEM[LOC(A1)]+1 STEP 1 UNTIL NN DO
BEGIN
IF TMPB_ON(MEM[I]) THEN
BEGIN
INTEGER ITEMVAR IV;
IV←NEW(MEM[I]);
SET_TYPE(IV,REF_CODE);
DELETE(IV);
MEM[I]←0;
END;
END;
END;
RETURN($REC$(OP,A1));
END;
IFCR FALSE THENC
SIMPLE PROCEDURE $PDSC$(INTEGER OP,A1);
BEGIN
LABEL XIT;
INTEGER N,I;
START_CODE
EXTERNAL INTEGER $REC$;
MOVE 3,OP;
CAIE 3,5;
JRST $REC$; ! only death is different;
SKIPN 1,A1;
JRST XIT;
PUSH '17,1;
PUSHJ '17,RECLEN;
MOVEM 1,N;
END;
FOR I←1 STEP 1 UNTIL N DO
BEGIN
INTEGER ITEMVAR IV;
IF ¬TMPB_ON(MEM[A1+I]) THEN CONTINUE;
IV←NEW(MEM[A1+I]);
SET_TYPE(IV,REF_CODE);
DELETE(IV);
END;
$DELB(A1-1);
XIT: END;
ENDC
! pattdsc;
RPTR($CLASS) PROCEDURE PATTDSC(INTEGER N);
BEGIN
RPTR($CLASS) PD;
PD←PTYPES[N];
IF PD=NULL_RECORD THEN
BEGIN
INTEGER ARRAY PDE[0:N];
STRING ARRAY PDS[0:N];
INTEGER I;
PD←NEW_RECORD($CLASS);
PDE[0]←HASRPS;
PDS[0]←"PDSC"&CVS(N);
FOR I←1 STEP 1 UNTIL N DO PDE[I]←REF_CODE LSH 23;
$CLASS:HNDLER[PD]←LOC($PDSC$);
$CLASS:RECSIZ[PD]←N;
I←LOC($CLASS:RECRNG[PD])+1;
$CLASS:RECRNG[PD]←I LSH 18 + I;
MEM[LOC($CLASS:TYPARR[PD])]↔MEM[LOC(PDE)];
MEM[LOC($CLASS:TXTARR[PD])]↔MEM[LOC(PDS)];
PTYPES[N]←PD;
END;
RETURN(PD);
END;
! pattblk;
INTERNAL RPTR(ANY_CLASS) PROCEDURE PATTBLK(LIST PL);
BEGIN
RPTR(ANY_CLASS) PB;
RPTR($CLASS) PD;
INTEGER PBB;
INTEGER I,N;
INTEGER ITEMVAR IV;
N←LENGTH(PL);
IF N=0 THEN RETURN(NULL_RECORD);
PD←PATTDSC(N);
IF $CLASS:HNDLER[PD]≠LOC($PDSC$) THEN
USERERR(1,1,"PATTERN CLASS CLOBBERED");
START_CODE "PBASGN"
EXTERNAL INTEGER $RECFN;
PUSH '17,[1];
PUSH '17,PD;
PUSHJ '17,$RECFN;
MOVEM 1,PB;
MOVEM 1,PBB;
END;
FOR I←1 STEP 1 UNTIL N DO
BEGIN
IV←LOP(PL);
IF TYPEIT(IV)≠REF_CODE THEN
USERERR(1,1,"LOSSAGE: NON-REF ITEM TO PATTBLK");
! IF ∂(IV) LAND '020000000000 THEN ! to get around a SAIL lossage;
! ∂(IV) ← ∂(IV) LAND '407777777777;
MEM[PBB+I]←∂(IV);
IF TMPB_ON(∂(IV)) THEN
BEGIN
SET_TYPE(IV,INTEGER_CODE);
DELETE(IV);
END
ELSE IF ¬REFB_ON(∂(IV)) THEN
USERERR(1,1,"WARNING: NON-TEMP VALUE REFITEM TO PATTBLK");
END;
RETURN(PB);
END;
! bapply,execpatt,do_demons,set_demon;
SIMPLE PROCEDURE BAPPLY(REFERENCE STRING SR;REFERENCE INTEGER NSR;
INTEGER PDA,ARGS);
START_CODE
EXTERNAL INTEGER APPLY;
JRST APPLY;
END;
RECURSIVE PROCEDURE EXECPATT(RANY PTN);
BEGIN
INTEGER N,PB,PD;
STRING SR;INTEGER NSR;
ITEMVAR PDI;
OWN INTEGER ARRAY ARGBUF[0:10];
LABEL GRIPE;
N←$CLASS:RECSIZ[$RECTYPE(PTN)];
IF N≤10 THEN
BEGIN
PB←MEM[LOC(PTN)];
IF N>1 THEN ARRBLT(ARGBUF[1],MEM[PB+2],N-1);
ARGBUF[N]←0;
PD←MEM[PB+1];
IF ¬ITEMB_ON(PD)∨ARY2B_ON(PD) THEN
GO TO GRIPE;
PDI←MEM[PD,ITEMVAR];
IF TYPEIT(PDI)≠PROC_CODE THEN
GO TO GRIPE;
BAPPLY(SR,NSR,∂(PDI,INTEGER),LOC(ARGBUF[0]));
END
ELSE
BEGIN
GRIPE: BUG("BAD CALL TO EXECPATT");
END;
END;
INTERNAL RECURSIVE PROCEDURE DO_DEMONS(ITEMVAR WLD,OCCASION;
RPTR(FACT) ITEMVAR FID);
BEGIN
ITEMVAR WLDSAVE;
RPTR(FACT) ITEMVAR DFI;
RPTR(FACT) FSAVE,DSAVE;
SIMPLE PROCEDURE DMNCLN;
BEGIN
_DEMONF_←DSAVE;
_WLD_←WLDSAVE;
_FACT_←FSAVE;
END;
CLEANUP DMNCLN;
DSAVE←_DEMONF_;
WLDSAVE←_WLD_;
FSAVE←_FACT_;
∀ DFI | OCCASION⊗FID≡DFI DO
BEGIN
_DEMONF_←∂(DFI);
IF TRUE_IN(_DEMONF_,WLD) THEN
BEGIN
_WLD_←WLD;_FACT_←∂(FID);_OCCASION_←OCCASION;
IF TDEMONS_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"INVOKING ");
RECPRN(FACT:PATT[_DEMONF_]);
PRINT(" OCCASION=",OCCASION," FID=",
FID," WLD=",WLD,CRLF);
END;
EXECPATT(FACT:PATT[_DEMONF_]);
END;
END;
END;
INTERNAL PROCEDURE SET_DEMON(ITEMVAR WLD,OCCASION,FID;LIST PF);
BEGIN
MAKE OCCASION⊗FID≡FACT:ID[LPASRT(WLD,PF)];
END;
! asrtf, denyf, asrtpf & denypf;
INTERNAL RECURSIVE PROCEDURE DENYF(ITEMVAR WLD;RPTR(FACT) F);
BEGIN
RPTR(FACT) ITEMVAR FID;
RPTR(FACT) FSAVE;
INTEGER WIX;
FSAVE ← _FACT_;
WIX←WLDINX(WLD,-1);
IF TDENY_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"DENYING ");
RECPRN(FACT:PATT[F]);
PRINT("FOR WORLD ",WLD,CRLF);
END;
CLRWLD(F,WIX);
DO_DEMONS(WLD,WHEN_DENY,FACT:ID[F]);
IF UNTRUE(F) THEN
BEGIN
ERASE ANY⊗ANY≡FACT:ID[F];
ERASE ANY⊗FACT:ID[F]≡ANY;
ERASE FACT:ID[F]⊗ANY≡ANY;
! takes care of WHEN_ASSERT & WHEN_DENY. Actually,
erase more than that on the grounds that this
fact is ripe for reuse.
;
! *** alternative is to wait until want to overwrite ***;
END;
_FACT_←FSAVE;
END;
INTERNAL RECURSIVE RPTR(FACT) PROCEDURE ASRTF(ITEMVAR WLD;RPTR(FACT) F);
BEGIN
RPTR(FACT) ITEMVAR FID;
RPTR(FACT) RETF,FSAVE;
INTEGER WIX;
FSAVE←_FACT_;
WIX←WLDINX(WLD,-1);
SETWLD(F,WIX);
IF TASRT_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"ASSERTING ");
RECPRN(FACT:PATT[F]);
PRINT("FOR WORLD ",WLD,CRLF);
END;
RELIEVE(F,WLD);
DO_DEMONS(WLD,WHEN_ASSERT,FACT:ID[F]);
_FACT_←FSAVE;
RETURN(F);
END;
INTERNAL RPTR(FACT) PROCEDURE ASRTPF(ITEMVAR WLD;RANY PR);
ASRTF(WLD,DBASE[INSERT_REC(PR)]);
INTERNAL PROCEDURE DENYPF(ITEMVAR WLD;RANY PR);
BEGIN
INTEGER IX,WIX;
SIMPLE INTEGER PROCEDURE PROBEF( REFERENCE INTEGER I);
RETURN(PATTCMP(PR,FACT:PATT[DBASE[I]]));
IX←UBS(PROBEF,1,DBTOP);
IF IX≤0 ∨ EMPTY(IX) THEN RETURN;
DENYF(WLD,DBASE[IX]);
END;
! pmatch itself;
INTERNAL MATCHING RECPROC PMATCH(? ITEMVAR W;RANY PR;BOOLEAN NONUSE(FALSE));
BEGIN
IFCR PMBUGGY THENC
SPROUT_DEFAULTS PSTACK(6)+STRINGSTACK(2);
ELSEC
SPROUT_DEFAULTS PSTACK(4);
ENDC
RPTR (FACT) F;
RPTR (FACT) ITEMVAR FI;
INTEGER PMC;
INTEGER WIX,IX,BNDL;
INTEGER LL,UU,PL;
INTEGER I,K,FPRP;
INTEGER ARRAY PATTN[0:PL←RECLEN(PR)];
LIST SATL;
LABEL PMLOSE;
! **** when Quam puts up the new record runtimes (which will
support fixed release, should use it on SATL & should
revise MUSTBIND to be a record (so it won't come from
CORGET space) ****;
SIMPLE INTEGER PROCEDURE PROBEF( REFERENCE INTEGER I);
RETURN(PATTCMP(PR,FACT:PATT[DBASE[I]],BNDL));
IFCR FALSE THENC
SIMPLE PROCEDURE PRPINI;
START_CODE
EXTERNAL INTEGER $GETB;
DEFINE P = '17;
PUSH P,PL; ! copy len+1 words;
AOS (P);
PUSHJ P,$GETB;
MOVEM 1,PRP;
MOVE 2,1;
HRL 1,PR;
ADD 2,PL;
BLT 1,(2);
END;
SIMPLE PROCEDURE PRPKILL;
START_CODE
EXTERNAL INTEGER $DELB;
DEFINE P='17;
SKIPN 1,PRP;
POPJ P,;
PUSH P,1;
PUSHJ P,$DELB;
END;
CLEANUP PRPKILL;
ELSEC
SIMPLE PROCEDURE PRPINI;
BEGIN
ARRBLT(PATTN[0],MEM[MEM[LOC(PR)]],PL+1);
END;
ENDC
SIMPLE PROCEDURE BINDCHK;
START_CODE
LABEL L1,L2,XIT;
MOVEI 5,0;
HRLZI 7,QUESB LSH -18;
SETOM BNDL;
MOVE 2,PL; ! len of pattern record;
MOVEI 4,2; ! value of bindit;
L1: CAML 5,2; ! done?;
JRST XIT; ! yes;
MOVE 6,PATTN; ! points at pattn[0];
ADDI 6,1(5); ! pick up the field;
MOVE 3,(6);
TLNE 3,BINDB LSH -18; ! bindb on? ;
JRST L2; ! yes, unbound;
TLNN 3,QUESB LSH -18; ! quesb on? ;
AOJA 5,L1; ! no, must be bound;
ANDCAM 7,(6); ! always turn off QUESB;
TLNE 3,ITEMB LSH -18; ! only items can be unbound;
CAME 4,(3); ! is it unbound?? ;
AOJA 5,L1;
HRLZI 3,BINDB LSH -18; ! yes, turn on bindb;
IORM 3,(6);
L2: SKIPGE BNDL;
MOVEM 5,BNDL;
AOJA 5,L1;
XIT: SKIPGE BNDL;
MOVEM 2,BNDL;
END;
PROCEDURE LETGO;
BEGIN
WHILE LENGTH(SATL)>0 DO
BEGIN
FI←LOP(SATL);
F←∂(FI);
FACT:USECNT[F]←FACT:USECNT[F]-1;
END;
END;
CLEANUP LETGO;
PROCEDURE PMSUCTRC;
BEGIN
PRINT(CRLF&"PMATCH[",PMC,"] SUCCESS (",W,",");
RECPRN(FACT:PATT[F]);
PRINT(")"&CRLF);
END;
SATL←NIL;
! PL←RECLEN(PR);
PRPINI;
BINDCHK;
IF TPMATCH_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"PMATCH[",(PMC←PMCAL←PMCAL+1),"](",W," ,");
RECPRN(PR);
PRINT(")"&CRLF);
END;
IF UNBOUND(W) THEN
WIX←-1
ELSE
BEGIN
WIX←WLDINX(W);
IF WIX<0 THEN
GO TO PMLOSE;
END;
IF BNDL>0 THEN
BEGIN "HITSGET"
IX←UBS(PROBEF,1,DBTOP);
IF IX≤0 THEN GO TO PMLOSE;
UU←LL←IX;
WHILE UU<DBTOP DO
BEGIN
IF PATTCMP(PR,FACT:PATT[DBASE[UU+1]],BNDL) THEN
DONE;
UU←UU+1;
END;
WHILE LL>1 DO
BEGIN
IF PATTCMP(PR,FACT:PATT[DBASE[LL-1]],BNDL) THEN
DONE;
LL←LL-1;
END;
END
ELSE
BEGIN
LL←1;
UU←DBTOP;
END;
FOR IX←LL STEP 1 UNTIL UU DO
BEGIN "IXL"
IF EMPTY(IX) THEN CONTINUE;
F←DBASE[IX];
IF WIX≥0 ∧ ¬TSTWIX(F,WIX) THEN CONTINUE;
IF PL≠RECLEN(FACT:PATT[F]) THEN CONTINUE;
FPRP←MEM[LOC(FACT:PATT[F])];
FOR I←BNDL+1 STEP 1 UNTIL PL DO
BEGIN
IF ELTCMP(PATTN[I],MEM[FPRP+I]) THEN
CONTINUE "IXL";
IF BINDB_ON(PATTN[I]) THEN
BEGIN
FOR K←I+1 STEP 1 UNTIL PL DO
BEGIN
IF PATTN[I] = PATTN[K] THEN
IF ELTCMP(MEM[FPRP+I],MEM[FPRP+K]) THEN
CONTINUE "IXL";
END;
END;
END;
SATL[∞+1]←FACT:ID[F];
FACT:USECNT[F]←FACT:USECNT[F]+1;
IF ¬CRCALL THEN DONE;
! in this case only need one satisfier.
Also, don't want to bump usecnt since
you will never get back to unbump it. ;
END;
WHILE LENGTH(SATL)>0 DO
BEGIN "SATLL"
LABEL ALLBOUND;
FI←LOP(SATL);
F←∂(FI);
FPRP←MEM[LOC(FACT:PATT[F])];
FOR I←1 STEP 1 UNTIL PL DO
BEGIN
DOBIND(PATTN[I],MEM[FPRP+I]);
END;
_FACT_ ← F;
ALLBOUND: IF WIX≥0 THEN
BEGIN
IF TPMATCH_ON(PMDBTF) THEN
PMSUCTRC;
IF ¬ NONUSE THEN
USEFCT(F,W);
SUCCEED;
END
ELSE ∀ W | TRUE_IN(F,W) DO
BEGIN
IF TPMATCH_ON(PMDBTF) THEN
PMSUCTRC;
IF W≠ANY ∧ ¬ NONUSE THEN
USEFCT(F,W);
SUCCEED;
END;
FACT:USECNT[F]←FACT:USECNT[F]-1;
END;
PMLOSE: IF TPMATCH_ON(PMDBTF) THEN
BEGIN
PRINT(CRLF&"PMATCH[",PMC,"] FAILURE"&CRLF);
END;
FAIL;
END;
! lpmatch, lpasrt, lpdeny;
INTERNAL MATCHING RECPROC LPMATCH(? ITEMVAR WLD;LIST PL;BOOLEAN NONUSE(FALSE));
BEGIN
SPROUT_DEFAULTS PSTACK(2);
∀ ? WLD | PMATCH(WLD,PATTBLK(PL),NONUSE) DO
SUCCEED;
FAIL;
END;
INTERNAL RPTR(FACT) PROCEDURE LPASRT(ITEMVAR WLD;LIST PL);
RETURN(ASRTPF(WLD,PATTBLK(PL)));
INTERNAL PROCEDURE LPDENY(ITEMVAR WLD;LIST PL);
DENYPF(WLD,PATTBLK(PL));
! test program;
IFCR PMDEBUGGING THENC
REQUIRE 100 PNAMES;
ITEM W1,W2;
ITEM TURING,HUMAN,BILL,DICK,JANE,JEAN,SALLY,LIKES,KNOWS;
ITEMVAR W,X,Y,Z;
BOOLEAN ASDYFG,LPMFG,RLYFG;
RLYFG←TRUE;
CALLBAIL;
IF ASDYFG THEN
BEGIN
PRINT(CRLF&"ABOUT TO DO ASSERT & DENY TESTS"&CRLF);
PMDBST;
END;
LPASRT(W1,\(HUMAN,TURING));
PRINT("JUST DID ONE ASSERTION"&CRLF);
IF ASDYFG THEN
DBDUMP;
$RECGC;
PRINT("JUST GARBAGE COLLECTED"&CRLF);
IF ASDYFG THEN
DBDUMP;
LPASRT(W1,\(DICK,LIKES,SALLY));
LPASRT(W1,\(DICK,LIKES,TURING));
LPASRT(W2,\(DICK,LIKES,TURING));
LPDENY(W1,\(HUMAN,TURING));
LPASRT(W2,\(HUMAN,TURING));
LPDENY(W1,\(DICK,LIKES,TURING));
IF ASDYFG THEN
DBDUMP;
LPASRT(W1,\(TURING,LIKES,DICK));
LPASRT(W1,\(TURING,LIKES,SALLY));
LPASRT(W1,\(BILL,LIKES,SALLY));
LPASRT(W1,\(BILL,LIKES,JANE));
LPASRT(W1,\(HUMAN,SALLY));
LPASRT(W1,\(HUMAN,JANE));
LPASRT(W1,\(HUMAN,JANE));
IF ASDYFG THEN
DBDUMP;
LPASRT(W1,\(HUMAN,TURING));
LPASRT(W1,\(HUMAN,BILL));
LPDENY(W1,\(HUMAN,BILL));
LPASRT(W2,\(HUMAN,JEAN));
LPASRT(W2,\(SALLY,KNOWS,SALLY));
LPASRT(W2,\(SALLY,KNOWS,DICK));
LPASRT(W2,\(SALLY,KNOWS,DICK,LIKES,SALLY));
LPASRT(W2,\(SALLY,KNOWS,DICK,KNOWS,SALLY));
IF LPMFG THEN
BEGIN "LPMTST"
PRINT(CRLF&"ABOUT TO START LPMATCH TESTS"&CRLF);
PMDBST;
DBDUMP;
IF ¬LPMATCH(W2,\(HUMAN,JEAN)) THEN PRINT("HUMAN JEAN FAILED");
∀ | LPMATCH(W1,\(HUMAN,∃ X)) DO
BEGIN
PRINT(CRLF&"X=",X,CRLF);
LPASRT(W2,\(HUMAN,$ X));
END;
∀ | LPMATCH(W2,\(SALLY, BIND X, DICK, BIND X, SALLY) ) DO
BEGIN
PRINT(CRLF&"FOR SAMEIV TEST, X = ",X,CRLF);
END;
∀ | LPMATCH(W2,\(SALLY,BIND X,BIND Z,BIND Y,SALLY) ) DO
BEGIN
PRINT(CRLF&"SALLY ",X,Z,Y," SALLY"&CRLF);
END;
PRINT(FF&"BEFORE"&CRLF);
DBDUMP;
$RECGC;
PRINT(FF&"AFTER"&CRLF);
DBDUMP;
END;
IF RLYFG THEN
BEGIN "RLYTST"
RPTR(FACT) F1,F2,F3,F4;
PRINT(CRLF&"ABOUT TO START RELIES_ON TESTS"&CRLF);
CALLBAIL;
PMDBST;
F1←LPASRT(W1,\(BILL,LIKES,SALLY));
F2←LPASRT(W1,\(SALLY,LIKES,BILL));
F3←LPASRT(W1,\(BILL,LIKES,JANE));
SAY_RELIES(W1,FACT:ID[F2],F1);
SAY_RELIES(W1,FACT:ID[F3],F1);
DBDUMP;
DENYF(W1,F2);
DBDUMP;
LPASRT(W1,\(BILL,LIKES,SALLY));
DENYF(W1,F3);
DBDUMP;
F1←LPASRT(W2,\(DICK,LIKES,SALLY));
F2←LPASRT(W2,\(SALLY,LIKES,DICK));
F3←LPASRT(W2,\(SALLY,LIKES,BILL));
SAY_RELIES(W2,FACT:ID[F2],F3);
SAY_RELIES(W2,FACT:ID[F1],NEW_FBOOL(2,LIST2(F2,F3)));
ASRTF(W2,F2);
DENYF(W2,F2);
DENYF(W2,F3);
DBDUMP;
F1←LPASRT(W1,\(JANE,LIKES,DICK));
F2←LPASRT(W1,\(DICK,LIKES,JANE));
F3←LPASRT(W1,\(JANE,KNOWS,DICK));
F4←LPASRT(W1,\(DICK,KNOWS,JANE));
SAY_RELIES(W1,FACT:ID[F1],NEW_FBOOL(2,CONS(F4,LIST2(F2,F3))));
DENYF(W1,F2);
F1←LPASRT(W2,\(JANE,LIKES,DICK));
F2←LPASRT(W2,\(DICK,LIKES,JANE));
F3←LPASRT(W2,\(JANE,KNOWS,DICK));
F4←LPASRT(W2,\(DICK,KNOWS,JANE));
SAY_RELIES(W2,FACT:ID[F1],NEW_FBOOL(1,CONS(F4,LIST2(F2,F3))));
DENYF(W2,F2);
DBDUMP;
END
ENDC
END "PMATCH";